perm filename PLOT.SAI[X,ALS]2 blob
sn#067698 filedate 1973-10-25 generic text, type T, neo UTF8
00010 BEGIN "PLOT"
00020 DEFINE ⊂="COMMENT"; ⊂ AUG.2,1973;
00030 DEFINE ⊃="⊂";
00040 DEFINE CR="'15",LF="'12",CRLF="CR&LF",TB="'11";
00050 REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE_FILE;
00060 LABEL STARTP,STOPP;
00070 ⊂ DEFINE \=" "; DEFINE \="SAFE"; ⊂ Alternarte definitions;
00080 REQUIRE "LPC1[X,ALS]" LOAD_MODULE;
00090 FORTRAN REAL PROCEDURE SQRT(REAL X);
00100 FORTRAN REAL PROCEDURE ALOG10(REAL X);
00110 FORTRAN REAL PROCEDURE COS(REAL X);
00120 FORTRAN REAL PROCEDURE SIN(REAL X);
00130 INTEGER ZEROC,ZEROF,DX;
00140 EXTERNAL FORTRAN PROCEDURE LPC1(REFERENCE REAL IFFY;
00150 REFERENCE INTEGER MPTS;REFERENCE REAL CF;REFERENCE INTEGER M;
00160 REFERENCE REAL R0,ERRN,ERR,SPT;REFERENCE INTEGER NSP,ISSW);
00170 REQUIRE "F[X,ALS]" LOAD_MODULE;
00180 EXTERNAL FORTRAN PROCEDURE FRXFM
00190 (REFERENCE INTEGER M;REFERENCE REAL X,Y);
00200 \ REAL ARRAY A,B,C,D[0:512];
00210 REAL X,SX; \ REAL ARRAY WINDOW[0:512];
00220 INTERNAL REAL R0;
00230 INTEGER LPCOPT;
00240 \ INTEGER ARRAY DPYBUF[0:4095];
00250 \ INTEGER ARRAY LFILE[0:'177];
00260 \ INTEGER ARRAY SYMBOL[0:127];
00270 \ INTEGER ARRAY DAT,AVDAT[0:23];
00280 STRING ARRAY SAMPLE[0:127];
00290 INTEGER I,J,K,L,M,N,P,PP,Q,QQ,R,
00300 POINTX,STATE,DELTA,VAL,CHAN1,EOF,POINTT,POINTV;
00310 INTEGER PT0,PT1,PT2,X0,X1,Y0,Y1,X2,Y2,
00320 PTCNT,PICK,JP,JPX,OPT,OPT1,SHUFCT;
00330 INTEGER II,JJ,KK,NN,SEGC,BRK,EOFA,READ3,
00340 SEGTOT,SEGIN,IIT,JJT,KKT,NNT,SEGCT;
00350 BOOLEAN ER;
00360 INTEGER CHAN2,CHAN3,CHAN4,CHAN5,CHAN6,CHANX;
00370 \ INTEGER ARRAY BUF,BUFT[0:511];
00380 STRING FILEN,READ,READ1,READT,FILEO,READ2,FILEQ,TFILE,FILLST;
00390
00400 PROCEDURE OUTALL(STRING S);
00410 BEGIN
00420 STRING SS; INTEGER J;
00430 SETBREAK(18,0,NULL,"OSN");
00440 SS←SCAN(S,18,J);
00450 OUTSTR(SS);
00460 END;
00470
00480 PROCEDURE DATAIN;
00490 BEGIN
00500 INTEGER J;
00510 FOR J←0 STEP 1 UNTIL 511 DO BUF[J]←0;
00520 IF EOF=0 THEN ARRYIN(CHAN1,BUF[0],512)
00530 ELSE OUTSTR
00540 ("No more data with JJ= "&CVS(JJ)&"SEGC= "&CVS(SEGC)&CRLF);
00550 POINTX←POINT(12,BUF[0],-1);
00560 SEGC←II←II+12; JJ←II+11;
00570 END;
00580
00590 PROCEDURE DATTIN;
00600 BEGIN
00610 INTEGER J;
00620 FOR J←0 STEP 1 UNTIL 511 DO BUFT[J]←0;
00630 IF EOFA=0 THEN ARRYIN(CHAN2,BUFT[0],512)
00640 ELSE OUTSTR
00650 ("No more T0X data with JJ= "&CVS(JJ)&"SEGC= "&CVS(SEGC)&CRLF);
00660 POINTT←POINT(6,BUFT[0],-1);
00670 SEGCT←IIT←IIT+128; JJT←IIT+127;
00680 END;
00690
00700
00710 PROCEDURE PLOT;
00720 BEGIN
00730 INTEGER I,JP,K,LP;
00740 PTCNT←PTCNT+1; IF PTCNT≤4 THEN BEGIN
00750 POINTV←POINTX;
00760 K←LDB(POINTV); IF K>2047 THEN K←K-4096;
00770 K←K%8;
00780
00790 RIVECT(0,K);
00800 FOR I←0 STEP 1 UNTIL 127 DO BEGIN
00810 JP←ILDB(POINTV); IF JP>2047 THEN JP←JP-4096;
00820 D[DX]←JP; DX←DX+1;
00830 ⊃ SETFORMAT(10,3); ⊃ OUTSTR(CVS(I)&TB&CVG(JP)&CRLF);
00840 JP←JP%8;
00850 LP←JP-K; RVECT(1,LP); K←JP; END;
00860 RIVECT(0,-K);
00870 IF PTCNT=4 THEN BEGIN
00880 RIVECT(-200,-130);
00890 READ←CVSTR(SYMBOL[Q])[1 TO 1];
00900 IF OPT1=1 THEN BEGIN
00910 DPYSST(CVXSTR(LFILE[10])[2 TO 3]&" "&READ&" ? "&CVS(JPX));
00920 SETFORMAT(1,0);
00930 IF (J-JPX)<0 THEN DPYSST(CVS(J-JPX)) ELSE DPYSST("+"&CVS(J-JPX));
00940 SETFORMAT(3,0); END;
00950 IF OPT1≠1 THEN
00960 DPYSST(CVXSTR(LFILE[10])[2 TO 3]&" "&READ&" "&CVS(J)&" "&CVS(KK));
00970 RIVECT(60,130); END;
00980 END;END;
00990
01000 PROCEDURE FRIC;
01010 BEGIN
01020 INTEGER JJJ;
01030 ⊂ STATE=0 means on way up
01040 STATE=1 means on way down;
01050 M←0;
01060 PLOT;
01070 FOR JJJ←0 STEP 1 UNTIL 127 DO BEGIN
01080 VAL←ILDB(POINTX); IF VAL>2047 THEN VAL←VAL-4096;
01090 IF STATE=0 THEN BEGIN
01100 IF VAL<K-DELTA THEN BEGIN
01110 M←M+(K-VAL); STATE←-1; END; END ELSE
01120 IF VAL>K+DELTA THEN BEGIN
01130 M←M+(VAL-K); STATE←0; END;
01140 K←VAL;
01150 IF JJJ=0 THEN M←0;
01160 END;
01170 M←M%100; IF M>63 THEN M←63;
01180 SEGC←SEGC+1;
01190 END;
01200
01210 PROCEDURE DATA;
01220 BEGIN
01230 INTEGER I;
01240 FOR I←0 STEP 1 UNTIL 23 DO BEGIN
01250 DAT[I]←ILDB(POINTT);
01260 AVDAT[I]←AVDAT[I]+DAT[I];
01270 END;
01280 SEGCT←SEGCT+1;
01290 END;
01300
01310 PROCEDURE TYDATT;
01320 BEGIN
01330 INTEGER I,J,K;
01340 K←0;
01350 FOR I←0 STEP 1 UNTIL 23 DO BEGIN
01360 J←ILDB(POINTT);
01370 OUTALL(CVS(J));
01380 END; OUTSTR(CRLF); END;
01390
01400 PROCEDURE SKIP;
01410 BEGIN
01420 INTEGER JJJ;
01430 FOR JJJ←0 STEP 1 UNTIL 127 DO IBP(POINTX);
01440 K←LDB(POINTX); IF K>2047 THEN K←K-4096;
01450 SEGC←SEGC+1;
01460 ⊃ OUTSTR("Skip to segc= "&CVS(SEGC)&CRLF);
01470 END;
01480
01490 PROCEDURE SKIPT;
01500 BEGIN
01510 INTEGER JJJ;
01520 FOR JJJ←0 STEP 1 UNTIL 23 DO IBP(POINTT);
01530 SEGCT←SEGCT+1;
01540 ⊃ OUTSTR("Skip to segct= "&CVS(SEGCT)&CRLF);
01550 END;
01560
01570 PROCEDURE SHUFFLE;
01580 BEGIN "SHUF"
01590 INTEGER I,J,K;
01600
01610 AIVECT(-640,-365);
01620 I←DPYPTR-PT1; ⊂ Words to save;
01630 J←PT1-PT0; ⊂ Words to overwrite;
01640 FOR K←1 STEP 1 UNTIL I DO DPYBUF[K+3]←DPYBUF[K+3+J];
01650 FOR K←I+1 STEP 1 UNTIL J+I DO DPYBUF[K+3]←1;
01660 PT1←DPYPTR←PT0+I;
01670 DPYOUT(0); PTOCHW(0,'10120);
01680 END "SHUF";
01690
01700 PROCEDURE RARDIS;
01710 BEGIN
01720 INTEGER I,J,K,SP;
01730 INTEGER LY,DY;
01740 REAL MAX,MIN;
01750
01760 MAX←-1000.;MIN←10000.;
01770 FOR I←0 STEP 1 UNTIL N%2 DO IF C[I]>MAX THEN MAX←C[I];
01780 SP←2; COMMENT HORIZONTAL SPACING;
01790 FOR I←0 STEP 1 UNTIL N%2-1 DO BEGIN
01800 C[I]←5.5*(C[I]+48-MAX); IF C[I]<0 THEN C[I]←0; END;
01810 RIVECT(0,80);
01811
01812 DPYSST("6"); RIVECT(-15,-20); DPYSST("D"); RIVECT(-15,-20);
01813 DPYSST("B"); RIVECT(-15,-40); DPYSST("s"); RIVECT(-15,-20);
01814 DPYSST("t"); RIVECT(-15,-20); DPYSST("e"); RIVECT(-15,-20);
01815 DPYSST("p"); RIVECT(-15,-20); DPYSST("s"); RIVECT(120,-64);
01816 DPYSST("2.5"); RIVECT(104,0); DPYSST("5"); RIVECT(94,0);
01817 DPYSST("7.5"); RIVECT(94,0); DPYSST("10"); RIVECT(-535,296);
01818
01820 FOR I←0 STEP 1 UNTIL 3 DO BEGIN
01830 RVECT(-10,0); RVECT(10,0); RVECT(0,-33);
01840 RVECT(-5,0); RIVECT(5,0); RVECT(0,-33); END;
01850 FOR I←0 STEP 1 UNTIL 7 DO BEGIN
01860 RVECT(32,0); RVECT(0,-5); RIVECT(0,5);
01870 RVECT(32,0); RVECT(0,-10); RIVECT(0,10); END; RIVECT(-512,0);
01880 LY←C[0]; RIVECT(0,LY);
01890 FOR I←0 STEP 1 UNTIL N%2 DO
01900 BEGIN
01910 DY←C[I]-LY;
01920 LY←LY+DY;
01930 RVECT(SP,DY);
01940 END;
01950 RIVECT(0,128-LY);
01960 END "RARDIS";
01970
01980 INTERNAL PROCEDURE XRTRAN(REAL ARRAY A,B;INTEGER N,EVALUATE);
01990 BEGIN
02000 COMMENT IF EVALUATE IS FALSE THIS INTERNAL PROCEDURE UNSCRAMBLES THE SINGLE VARIATE
02010 COMPLEX TRANSFORM ;
02020 INTEGER K,NK,NH;
02030 REAL AA,AB,BA,BB,RE,IM,CK,SK,DC,DS,R;
02040 NH←N%2; R←3.1415926536/N;
02050 DS←SIN(R); R←-(2*SIN(0.5*R))↑2;
02060 DC←-0.5*R; CK←1.0; SK←0;
02070 IF EVALUATE THEN
02080 BEGIN
02090 CK←-1.0; DC←-DC;
02100 END
02110 ELSE
02120 BEGIN
02130 A[N]←A[0]; B[N]←B[0];
02140 END;
02150 FOR K←0 STEP 1 UNTIL NH DO
02160 BEGIN
02170 NK←N-K;
02180 AA←A[K]+A[NK]; AB←A[K]-A[NK];
02190 BA←B[K]+B[NK]; BB←B[K]-B[NK];
02200 RE←CK*BA+SK*AB; IM←SK*BA-CK*AB;
02210 B[NK]←IM-BB; B[K]←IM+BB;
02220 A[NK]←AA-RE; A[K]←AA+RE;
02230 DC←R*CK+DC; CK←CK+DC;
02240 DS←R*SK+DS; SK←SK+DS;
02250 END;
02260 END "XRTRAN";
02270
02280 INTERNAL PROCEDURE FORM(INTEGER LPCOPT);
02290 BEGIN "FORM"
02300 REAL ERRN,ERR;
02310 INTEGER I,J;
02320 M←9; N←2↑M; DEFINE PI="3.141592653";
02330 IF WINDOW[N%2]=0 THEN
02340 FOR I←0 STEP 1 UNTIL N DO WINDOW[I]←(1-COS((2*PI*I)/N))/2;
02350 FOR I←0 STEP 1 UNTIL N DO A[I]←D[I];
02360 IF LPCOPT=0 THEN BEGIN "LPC"
02370 FOR I←0 STEP 1 UNTIL N-2 DO A[I]←(A[I+1]-A[I])*WINDOW[I];
02380 ⊂ LOADS DATA IN A, DIFFERENTIATES AND WINDOWS ;
02390 I←24; J←N%2; LPC1(A[0],N,B[0],I,R0,ERRN,ERR,C[0],J,1);
02400 END "LPC" ELSE BEGIN "FFT"
02410 FOR I←0 STEP 1 UNTIL N DO BEGIN
02420 A[I]←D[I]*WINDOW[I]; B[I]←0;
02430 ⊃ SETFORMAT(10,3); ⊃ OUTSTR(CVS(I)&TB&CVG(D[I])&TB&CVG(A[I])&CRLF);
02440 END; I←24; J←N%2;
02450 FRXFM(M,A[0],B[0]);
02460 ⊃ OUTSTR("FFT COMPLETE"&CRLF);
02470 FOR I←0 STEP 1 UNTIL N%2 DO BEGIN
02480 X←A[I]↑2+B[I]↑2+1.*10↑-37;
02490 ⊃ OUTSTR(CVG(A[I])&" "&CVG(B[I])&" "&CVG(X)&TB);
02500 C[I]←10.*ALOG10(X); END;
02510 END "FFT";
02520 RARDIS;
02530 END "FORM";
00010 TYPLOC(512,80);
00020 DPYSET(DPYBUF); AIVECT(-640,-90); PT0←DPYPTR;
00030 SHUFCT←0;AIVECT(-640,-365);PT1←DPYPTR;
00040 FILEN←"HI20.001[CMP,JH]";
00050 FILEO←"SEG1.FRI";
00060 ⊂ HEADIN;
00070 STDBRK(1);
00080 SETBREAK(14,"∃",NULL,"INS");
00090 SETBREAK(15,'11&'12&'14&'15&'40,NULL,"INS");
00100 SETBREAK(16,'56,NULL,"INA");
00110 SETBREAK(17,'12,'15,"INS");
00120
00130 CHAN1←1; CHAN2←2; CHAN3←3; CHAN4←4; CHAN5←5; CHAN6←6;
00140 OUTSTR("This program will show header information and wave forms for"
00150 &CRLF&" a selected phonette. After every display it waits for a "
00160 &crlf&" single letter command or a number(followed by a CR)."&CRLF&
00170 " A space bar causes it to continue, a letter S causes it "
00180 &CRLF&"start over by asking for a phonette, while an E exits."&CRLF);
00190 OUTSTR("A positive or negative number causes it to shift by the specified "&
00200 CRLF&"amount and then give data for the next 4 segments."&CRLF);
00210 OUTSTR("At present this program takes acoustic data from [CMP,JH],"&
00220 CRLF&" indentifying information from MAP.PHM[11,ALS]"&
00230 CRLF&" and header information from files .T0X[11,ALS]."&CRLF&LF);
00240
00250 CLOSE(CHAN4); OPEN(CHAN4